;; displayw.lsp
;; Copyright (c) 1999-2000 by Forrest W. Young
;; Creates a window for displaying text. Extends the Mac-only
;; display window (Tierney, p. 360) to work on all platforms.



#+macintosh(defmeth display-window-proto :scroll (&rest args))

(defun paste-text (w text)
  (send w :paste-string text))

#+macintosh
(defun show-display-window (w)
  (when (not (equal (front-window) w)) (send w :show-window))
  w)

#-macintosh
(defun show-display-window (w)
  (defmeth w :redraw () (send self :redraw-it))
(defmeth w :resize () (send self :resize-it))
(defmeth w :reformat () (send self :reformat-it))
  (if (> (* (+ 2 (send w :nlines)) (send w :line-height))
           (second (send w :size)))
       (send w :has-v-scroll (* (+ 2 (send w :nlines)) 
                                (send w :line-height)))
       (send w :has-v-scroll nil))
  #+macintosh (when (not (equal (front-window) w)) (send w :show-window))
  #-macintosh (send w :show-window)
  w) 

(defun write (text w)
"Writes TEXT to W, scrolling window contents and adjusting window to fit, if necessary and possible"
  (add-text w text :show t :fit t :scroll t))

#+macintosh 
(defun add-text (w text &key (show t) fit scroll)
  (send w :paste-string text))

#-macintosh
(defun add-text (w text &key (show t) fit scroll)
 (let* ((line-height (send w :line-height))
        (nlines (send w :nlines))
        (window-height (second (send w :size)))
        (text-height (* nlines line-height)))
   (send w :write-now t)
   (send w :paste-string text) 
   (when (and scroll (> (+ text-height line-height) (- window-height line-height)))
         (send w :has-v-scroll (+ text-height (* 2 line-height)))
         (apply #'send w :scroll (+ (list 0 (* 2 line-height)) (send w :scroll))))
   (when (and show (not (send w :showing)))(send w :show-window))))
  

(defun file-to-window (filename title w &optional (flush t) (add-help t))
  (send *vista* :file-to-help-window filename title w flush add-help)
  w)

(defun file-to-stream (filename title &optional (out-stream *standard-output*))
  (cond
    ((equal out-stream *standard-output*)
     (send *vista* :file-to-help-window 
           filename title (send *vista* :help-window-object)))
    (t
     (gc)
     (if (equal title "Bug List")
         (format out-stream 
                 "~3%**************** ~a  ****************~2%" 
                 title)
         (format out-stream 
                 "~3%****************  Help for ~a  ****************~2%" 
                 title))
     (with-open-file (in-stream filename :direction :input)
                     (let ((char nil))
                       (loop ;loop until eof
                             (if (setq char (read-char in-stream nil nil))
                                 (write-char char out-stream)
                                 (return nil)))))
     (terpri))))


(defproto display-window-proto2 
  '(x y nstrings strings nlines lines line-height line-width write-now
      default-window-height fit-window-to-text-height nowrap noformat
      v-scroll-value x-list y-list reformatting showing true-location 
      pop-out? fit? menu? pop-out-on-show showing top-most? top-most-menu-item
      window-chain?
      used?
      )
  () graph-window-proto)

(defmeth display-window-proto2 :isnew 
  (&key (title "Text Window") (size '(475 280)) 
        (location '(10 20)) (show t))
  (call-next-method :title title :size size :show nil)
                    ;:location (+ (list 0 20) location)
  (apply #'send self :location location);(- (send self :location) (list 4 24))
  (send self :flush-window)
  (send self :window-chain? nil)
  (send self :line-height (+ (send self :text-ascent)
                             (send self :text-descent)))
  (send self :default-window-height (* 5 (send self :line-height)))
  (let* ((window-width (first (send self :size)))
         (window-height (second (send self :size)))
         (line-height (send self :line-height))
         (v-page-increment (* line-height 
                            (floor (/ (- window-height line-height) 
                                      line-height))))
         )
    (send self :make-menu)
    (send (send self :menu) :remove)
    (send self :has-v-scroll t) 
    (send self :v-scroll-incs line-height v-page-increment)
    (send self :has-h-scroll t)
    (send self :h-scroll-incs 
          (floor (/ window-width 20)) (floor (/ window-width 2)))
    ) 
  (send self :pop-out-on-show t)
  (when show (send self :show-window :relocate nil))
  (when (not *current-text-window*)
        (send save-text-file-menu-item :enabled t))
  (setf *current-text-window* self)
  t)

(defmeth display-window-proto2 :x (&optional (number nil set))
  (if set (setf (slot-value 'x) number))
  (slot-value 'x))

(defmeth display-window-proto2 :y (&optional (number nil set))
  (if set (setf (slot-value 'y) number))
  (slot-value 'y))

(defmeth display-window-proto2 :x-list (&optional (list-of-nums nil set))
  (if set (setf (slot-value 'x-list) list-of-nums))
  (slot-value 'x-list))

(defmeth display-window-proto2 :y-list (&optional (list-of-nums nil set))
  (if set (setf (slot-value 'y-list) list-of-nums))
  (slot-value 'y-list))

(defmeth display-window-proto2 :nstrings (&optional (number nil set))
  (if set (setf (slot-value 'nstrings) number))
  (slot-value 'nstrings))

(defmeth display-window-proto2 :strings (&optional (list-of-strings nil set))
  (if set (setf (slot-value 'strings) list-of-strings))
  (slot-value 'strings))

(defmeth display-window-proto2 :nlines (&optional (number nil set))
  (if set (setf (slot-value 'nlines) number))
  (slot-value 'nlines))

(defmeth display-window-proto2 :lines (&optional (list-of-strings nil set))
  (if set (setf (slot-value 'lines) list-of-strings))
  (slot-value 'lines))

(defmeth display-window-proto2 :line-height (&optional (number nil set))
  (if set (setf (slot-value 'line-height) number))
  (slot-value 'line-height))

(defmeth display-window-proto2 :line-width (&optional (number nil set))
  (if set (setf (slot-value 'line-width) number))
  (slot-value 'line-width))

(defmeth display-window-proto2 :write-now  (&optional (logical nil set))
  (if set (setf (slot-value 'write-now) logical))
  (slot-value 'write-now))

(defmeth display-window-proto2 :used? (&optional (logical nil set))
  (if set (setf (slot-value 'used?) logical))
  (slot-value 'used?))

(defmeth display-window-proto2 :window-chain? (&optional (logical nil set))
  (if set (setf (slot-value 'window-chain?) logical))
  (slot-value 'window-chain?))

(defmeth display-window-proto2 :fit-window-to-text-height 
  (&optional (logical nil set))
  (if set (setf (slot-value 'fit-window-to-text-height) logical))
  (slot-value 'fit-window-to-text-height))

(defmeth display-window-proto2 :reformatting (&optional (logical nil set))
  (if set (setf (slot-value 'reformatting) logical))
  (slot-value 'reformatting))

(defmeth display-window-proto2 :showing (&optional (logical nil set))
  (if set (setf (slot-value 'showing) logical))
  (slot-value 'showing))

(defmeth display-window-proto2 :default-window-height 
  (&optional (number nil set))
  (if set (setf (slot-value 'default-window-height) number))
  (slot-value 'default-window-height))

(defmeth display-window-proto2 :nowrap  (&optional (logical nil set))
  (if set (setf (slot-value 'nowrap) logical))
  (slot-value 'nowrap))

(defmeth display-window-proto2 :noformat  (&optional (logical nil set))
  (if set (setf (slot-value 'noformat) logical))
  (slot-value 'noformat))

(defmeth display-window-proto2 :pop-out? (&optional (logical nil set))
  (if set (setf (slot-value 'pop-out?) logical))
  (slot-value 'pop-out?))

(defmeth display-window-proto2 :fit? (&optional (logical nil set))
  (if set (setf (slot-value 'fit?) logical))
  (slot-value 'fit?))

(defmeth display-window-proto2 :menu? (&optional (logical nil set))
  (if set (setf (slot-value 'menu?) logical))
  (slot-value 'menu?))

(defmeth display-window-proto2 :print-buffer (&optional (window-obj nil set))
  (if set (setf (slot-value 'print-buffer) window-obj))
  (slot-value 'print-buffer))

(defmeth display-window-proto2 :v-scroll-value (&optional (number nil set))
  (if set (setf (slot-value 'v-scroll-value) number))
  (slot-value 'v-scroll-value))

(defmeth display-window-proto2 :do-click (x y m1 m2) 
  (when (not (equal *current-text-window* self))
        (setf *current-text-window* self)))

(defmeth display-window-proto2 :top-most-menu-item (&optional (obj nil set))
  (if set (setf (slot-value 'top-most-menu-item) obj))
  (slot-value 'top-most-menu-item))

(defmeth display-window-proto2 :top-most? (&optional (logical nil set))
  (when set (setf (slot-value 'top-most?) logical)
            (send (send self :top-most-menu-item) :mark logical))
  (slot-value 'top-most?))

(defmeth display-window-proto2 :top-most (&optional (logical nil set))
  (if set 
      (progn
       (send self :top-most? logical)
       (call-next-method logical))
      (call-next-method)))
        
(defmeth display-window-proto2 :paste-stream (stream)
  (let ((string nil))
    (loop
     (setf string (read-line stream nil))
     (when (not string) (return))
     (setf string (strcat string (string #\newline)))
     (when mytrace (format t "LENGTH: ~3d STREAM: ~s~%" 
                           (length string) string))
     (send self :paste-string string))
    ))

(defmeth display-window-proto2 :paste-string (string &key (newlines t))
  (let* ((last-char nil)
         (string-piece string)
         (string-max string-piece)
         (string-length nil)
         (more nil)
         (split-loc 0)
         (newline-loc)
         (max-char 100))
    (when (not newlines)
          (setf newline-loc (position #\newline string-piece))
          (when newline-loc
                (setf string (subseq string (1+ newline-loc) (length string)))
                (setf string-piece string)))
    (cond 
      ((send self :noformat)
       (loop 
        (setf string-piece string)
        (setf split-loc (position #\newline string-piece))
        (cond
          (split-loc
           (when (> split-loc 0)
                 (setf string-piece (select2 string-piece (iseq split-loc)))
                 (send self :lines 
                       (add-element-to-list (send self :lines) string-piece))
                 (setf string-length (send self :text-width string-piece))
                 (send self :strings 
                       (add-element-to-list (send self :strings) string-PIECE))
                 (send self :write-line-to-window 
                       string (send self :x) (send self :y) string-length))
           (send self :new-line (send self :y))
           (send self :strings (add-element-to-list 
                  (send self :strings) (string #\newline)))
           (when (> (1+ split-loc) (1- (length string))) (return))
           (setf string (select2 string 
                                 (iseq (1+ split-loc) (1- (length string))))))
          (t
           (send self :lines 
                 (add-element-to-list (send self :lines) string-piece))
           (setf string-length (send self :text-width string-piece))
           (send self :write-line-to-window 
                 string (send self :x) (send self :y) string-length)
           (send self :strings 
                 (add-element-to-list (send self :strings) string-PIECE))
           (send self :nstrings (1+ (send self :nstrings)))
           (return)))))
      ((> (length string) 0)
       (setf last-char (select2 (reverse string) 0))
       (when (and (not (equal last-char #\ ))
                  (not (equal last-char #\newline)))
                (setf string (strcat string " "))
                (setf string-piece string)
                (setf string-max string-piece))
          (loop (setf more nil)
                (setf string-length (length string-piece))
                (when (> string-length max-char)
                      (setf string-max 
                            (reverse (select2 string-piece (iseq max-char))))
                      (setf split-loc (- max-char (position #\  string-max)))
                      (setf string-max 
                            (select2 (reverse string-max) (iseq split-loc)))
                      (setf more t)
                      )
                (send self :strings 
                      (add-element-to-list (send self :strings) string-max))
                (send self :nstrings (1+ (send self :nstrings)))
                
                (when (> (length string-max) 0) 
                      (send self :write-string-to-window string-max))
                (when more
                      (setf max-char 
                            (min max-char (- string-length split-loc)))
                      (setf string-piece 
                            (select2 string-piece 
                                     (iseq split-loc (- string-length 1))))
                      (setf string-max string-piece)
                   )
                (when (not more) (return)))))
  t))

(setf mytrace nil)
(setf mybreak nil)

(defmeth display-window-proto2 :write-string-to-window (string)
  (let ((x (send self :x))
        (y (send self :y))
        (string-width (send self :text-width string))
        (line-width (send self :line-width))
        (line-width-remaining nil)
        (old-line-remaining string)
        (pieces nil)
        (piece-width nil)
        (splitable string)
        (vr (send self :view-rect))
        )
    (when (not line-width)
          (if (= 0 (send self :canvas-width))
              (send self :line-width 400)
              (send self :line-width (- (send self :canvas-width) 20)))
          (setf line-width (send self :line-width)))
    (setf line-width-remaining (- (send self :line-width) x))
    (loop 
     (setf pieces (send self :split-line splitable x line-width-remaining))
     (when (and (equal (third pieces) old-line-remaining)
                (not (position #\  (third pieces)))
                (<= (send self :line-width)
                    (send self :text-width (third pieces))))
           (when mytrace
                 (format t "IN WIERD PLACE - Line Width ~d <= Text Width ~d~%~a~%"
                         (send self :line-width)
                         (send self :text-width (third pieces)) (third pieces)))
           (setf line-width-remaining (send self :line-width))
           (setf piece-width (send self :text-width (third pieces)))
           (send self :lines 
                 (add-element-to-list (send self :lines) (third pieces)))
           (send self :write-line-to-window (third pieces) x y piece-width)
           (setf splitable nil)
           (return)
           )
     (setf old-line-remaining (third pieces))
     (when (first pieces)
           (setf piece-width (send self :text-width (first pieces)))
           (send self :lines 
                 (add-element-to-list (send self :lines) (first pieces)))
           (send self :write-line-to-window (first pieces) x y piece-width))
     (when (<= (send self :line-width) (send self :x)))
     (when (equal (second pieces) "NL")(send self :new-line y))
     (cond 
       ((third pieces) 
        (when (not (equal (second pieces) "NL"))(send self :new-line y))
        (setf x (send self :x))
        (setf y (send self :y))
        (setf line-width-remaining (send self :line-width))
        (setf splitable (third pieces)))
       (t (return))))))

(defmeth display-window-proto2 :split-line (string x line-width)
  (let* ((string-length (length string))
         (nowrap (send self :nowrap))
         (margins 0)
         (real-line-width (- line-width margins))
         (first-newline-loc nil)
         (last-space-loc nil)
         (split-loc nil)
         (print-string string)
         (previous-print-string string)
         (print-string-width (send self :text-width print-string))
         (print-string-length (length print-string))
         (remaining-string nil)
         (print-string-backwards nil)
         (last-space-loc nil)
         (last-nl-loc nil)
         )

    (when (<= real-line-width 0) (setf real-line-width 20))

    (if mytrace (format t "~%SPLITABLE LINE:  ~s~%"string)) 
    (if mybreak (break))

    (when (not nowrap)
    (loop
     (if mytrace 
        (format t "OUTER LOOP: psw ~d rlw ~d psl ~d ~s~%" print-string-width
                real-line-width print-string-length print-string)
          )
     (when (< print-string-width real-line-width) 
           (setf print-string previous-print-string)
           (setf print-string-length (length print-string))
           (setf print-string-width (send self :text-width print-string))
           (loop
            (if mytrace 
                (format t "INNER LOOP: psw ~d rlw ~d psl ~d ~s~%" print-string-width
                        real-line-width print-string-length print-string)
                 )
            (when (< print-string-width real-line-width) (return))
            (setf print-string-length (- print-string-length 1))
            (setf print-string (select2 string (iseq print-string-length))) 
            (setf print-string-width (send self :text-width print-string)))
           (return))
     (setf previous-print-string print-string)
     (setf print-string-backwards (reverse print-string))
     (setf last-space-loc (position #\  print-string-backwards))
     (setf last-nl-loc (position #\newline  print-string-backwards))
     (when (and (not last-space-loc) (not last-nl-loc)) (return))
     (when (not last-space-loc) (setf last-space-loc print-string-length))
     (when (not last-nl-loc) (setf last-nl-loc print-string-length))
     (setf print-string-length 
           (- print-string-length (min last-space-loc last-nl-loc) 1))
     (setf print-string (select2 string (iseq print-string-length))) 
     (if print-string
         (setf print-string-width (send self :text-width print-string))
         (setf print-string-width 0))
     ))

    (if mytrace 
        (format t "AFTER LOOP: psw ~d rlw ~d psl ~d ~s~%" print-string-width
                real-line-width print-string-length print-string))
    (if mybreak (break))
    (setf first-newline-loc (position #\newline print-string))
    (if mytrace (format t "FNL ~d~%" first-newline-loc))
    (if first-newline-loc
        (setf split-loc (+ 1 first-newline-loc))
        (if (position #\  (reverse print-string))
            (setf split-loc 
                  (- print-string-length 
                     (position #\  (reverse print-string))))
            (setf split-loc 0))) 
    (if mytrace (format t "SPLIT-LOC ~d~%" split-loc))
    (if (= split-loc string-length);sometimes print-string-length
        (setf remaining-string nil)
        (setf remaining-string 
              (select2 string ;sometimes print-string 
                      (iseq split-loc (- string-length 1)))))
    ;above sometimes print-string-length
    ;make print-string the string up to (not incuding) split-loc
    (if mytrace (format t "REMAIN ~s~%" remaining-string))
    (if (= split-loc 0)
        (setf print-string nil)
        (setf print-string 
              (strcat " " (select2 print-string (iseq (- split-loc 1))))))
    (setf break-char (if first-newline-loc "NL" "SP"))
    (if mytrace (format t "AFTER SPLITTING: ~s ~s ~s~%" 
                        print-string break-char remaining-string))
    (if mybreak (break))
    (list print-string break-char remaining-string)))

(defmeth display-window-proto2 :write-line-to-window (string x y st-width)
  (when (send self :write-now) 
        (let ((vr (send self :view-rect)))
          (when (<= (second vr) y (+ (second vr) (fourth vr)))
                 (send self :draw-text string x y 0 1)
                 ))
        )
  (send self :x-list (add-element-to-list (send self :x-list) x))
  (send self :y-list (add-element-to-list (send self :y-list) y))
  (send self :x (+ (send self :x) st-width)))


(defmeth display-window-proto2 :new-line (y)
  (send self :nlines (1+ (send self :nlines)))
  (send self :y (+ (send self :y) (send self :line-height)))
  (send self :x 10)
  (send self :y))


(defmeth display-window-proto2 :redraw ()
  (when (send self :showing)
        (send self :redraw-it)))

(defmeth display-window-proto2 :redraw-it ()
  (when (and (send self :showing)
             (not (send self :reformatting))
             (send *vista* :ready-to-redraw self))
        (send self :erase-window)
        (let* ((y-top (second (send self :view-rect)))
               (y-now nil)
               (y-bot (+ y-top (fourth (send self :view-rect)))))
          (dotimes (i (length (send self :y-list)))
                   (setf y-now (select (send self :y-list) i))
                   (cond
                     ((<= y-top y-now y-bot)
                      (send self :draw-text 
                            (select (send self :lines) i)
                            (select (send self :x-list) i) y-now 0 1))
                     ((> y-now y-bot)
                      (return)))))
        (send *vista* :finished-redraw self)))
        
        
(defmeth display-window-proto2 :reformat ()
  (send self :reformat-it))

(defmeth display-window-proto2 :reformat-it ()
  (when (and (send self :showing)
             (send *vista* :ready-to-redraw self))
        (let ((write-before (send self :write-now)))
          (send self :write-now t)
          (send self :reformatting t)
          (when (not write-before) (send self :start-buffering))
          (cond 
            ((> (first (send self :size)) 200)
             (let ((nstrings (send self :nstrings))
                   (strings (send self :strings))
                   )
               (send self :erase-window)
               (send self :x 10)
               (send self :y 0)
               (send self :nlines 0)
               (send self :lines nil)
               (send self :x-list nil)
               (send self :y-list nil)
               (when nstrings
                     (dotimes (i nstrings)
                              (send self :write-string-to-window 
                                    (select2 strings i))))))
            (t (send self :size 201 (second (send self :size)))))
          (send self :write-now write-before)
          
          (let* ((window-height (second (send self :size)))
                 (line-height (send self :line-height))
                 (content-height 
                  (* line-height (1+ (send self :nlines))))
                 (page-increment (* line-height 
                                    (floor (/ (- window-height line-height) 
                                              line-height))))) 
            (cond
              ((> content-height (second (send self :size)))
               (send self :v-scroll-incs line-height page-increment)
               (send self :has-v-scroll content-height))
              (t
               (send self :has-v-scroll nil)))
            )
          (send self :reformatting nil)
          (when (not write-before) (send self :buffer-to-screen)))
        (send *vista* :finished-redraw self)))


(defmeth display-window-proto2 :resize ()
  (send self :resize-it))

(defmeth display-window-proto2 :resize-it ()
  (send self :line-width (- (send self :canvas-width) 20))
  (when (send self :noformat) (send self :redraw))
  (when (and (not (send self :noformat))
             (not (send self :reformatting)))
        (send self :reformat)))


(defmeth display-window-proto2 :flush-window ()
  (send self :erase-window)
  (send self :x 10)
  (send self :y 0)
  (send self :lines nil)
  (send self :x-list nil)
  (send self :y-list nil)
  (send self :strings nil)
  (send self :nstrings 0)
  (send self :nlines 0))

(defmeth display-window-proto2 :show-window ()
  (call-next-method)
  (send self :showing t)
  (send *vista* :help-showing t))

(defmeth display-window-proto2 :close ()
  (call-next-method)
  (send self :showing nil)
  (send *vista* :help-showing nil))

(defmeth display-window-proto2 :plot-help 
     (&optional (text "This window displays help and information messages.")
                (title "Help: Text Window"))
  (let* (
         (w (plot-help-window title)))
    (paste-plot-help  (format nil text))
    (show-plot-help)))
